home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / RxGraph.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  43.1 KB  |  1,475 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11.  
  12. Unit RxGraph;
  13.  
  14. interface
  15.  
  16. {$I RX.INC}
  17.  
  18. uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  19.   SysUtils, Classes, Graphics, VclUtils;
  20.  
  21. type
  22. {$IFNDEF RX_D3}
  23.   TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf24bit);
  24. {$ENDIF}
  25.   TMappingMethod = (mmHistogram, mmQuantize, mmTrunc784, mmTrunc666,
  26.     mmTripel, mmGrayscale);
  27.  
  28. function GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat;
  29. function GetPaletteBitmapFormat(Bitmap: TBitmap): TPixelFormat;
  30. procedure SetBitmapPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat;
  31.   Method: TMappingMethod);
  32. function BitmapToMemoryStream(Bitmap: TBitmap; PixelFormat: TPixelFormat;
  33.   Method: TMappingMethod): TMemoryStream;
  34. procedure GrayscaleBitmap(Bitmap: TBitmap);
  35.  
  36. function BitmapToMemory(Bitmap: TBitmap; Colors: Integer): TStream;
  37. procedure SaveBitmapToFile(const Filename: string; Bitmap: TBitmap;
  38.   Colors: Integer);
  39.  
  40. function ScreenPixelFormat: TPixelFormat;
  41. function ScreenColorCount: Integer;
  42.  
  43. procedure TileImage(Canvas: TCanvas; Rect: TRect; Image: TGraphic);
  44. function ZoomImage(ImageW, ImageH, MaxW, MaxH: Integer; Stretch: Boolean): TPoint;
  45.  
  46. const
  47.   DefaultMappingMethod: TMappingMethod = mmHistogram;
  48.  
  49. { TRxGradient class }
  50.  
  51. type
  52.   TRxGradient = class(TPersistent)
  53.   private
  54.     FStartColor: TColor;
  55.     FEndColor: TColor;
  56.     FDirection: TFillDirection;
  57.     FStepCount: Byte;
  58.     FVisible: Boolean;
  59.     FOnChange: TNotifyEvent;
  60.     procedure SetStartColor(Value: TColor);
  61.     procedure SetEndColor(Value: TColor);
  62.     procedure SetDirection(Value: TFillDirection);
  63.     procedure SetStepCount(Value: Byte);
  64.     procedure SetVisible(Value: Boolean);
  65.   protected
  66.     procedure Changed; dynamic;
  67.   public
  68.     constructor Create;
  69.     procedure Assign(Source: TPersistent); override;
  70.     procedure Draw(Canvas: TCanvas; Rect: TRect);
  71.   published
  72.     property Direction: TFillDirection read FDirection write SetDirection
  73.       default fdTopToBottom;
  74.     property EndColor: TColor read FEndColor write SetEndColor default clGray;
  75.     property StartColor: TColor read FStartColor write SetStartColor default clSilver;
  76.     property StepCount: Byte read FStepCount write SetStepCount default 64;
  77.     property Visible: Boolean read FVisible write SetVisible default False;
  78.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  79.   end;
  80.  
  81. implementation
  82.  
  83. {$R-}
  84.  
  85. uses Consts, MaxMin;
  86.  
  87. procedure InvalidBitmap; near;
  88. begin
  89.   raise EInvalidGraphic.Create(ResStr(SInvalidBitmap));
  90. end;
  91.  
  92. type
  93.   PRGBPalette = ^TRGBPalette;
  94.   TRGBPalette = array [Byte] of TRGBQuad;
  95.  
  96. function WidthBytes(I: Longint): Longint;
  97. begin
  98.   Result := ((I + 31) div 32) * 4;
  99. end;
  100.  
  101. function PixelFormatToColors(PixelFormat: TPixelFormat): Integer;
  102. begin
  103.   case PixelFormat of
  104.     pf1bit: Result := 2;
  105.     pf4bit: Result := 16;
  106.     pf8bit: Result := 256;
  107.     else Result := 0;
  108.   end;
  109. end;
  110.  
  111. function ScreenPixelFormat: TPixelFormat;
  112. var
  113.   DC: HDC;
  114. begin
  115.   DC := GetDC(0);
  116.   try
  117.     case (GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL)) of
  118.       1: Result := pf1bit;
  119.       4: Result := pf4bit;
  120.       8: Result := pf8bit;
  121.       24: Result := pf24bit;
  122.       else Result := pfDevice;
  123.     end;
  124.   finally
  125.     ReleaseDC(0, DC);
  126.   end;
  127. end;
  128.  
  129. function ScreenColorCount: Integer;
  130. begin
  131.   Result := PixelFormatToColors(ScreenPixelFormat);
  132. end;
  133.  
  134. { Quantizing }
  135. { Quantizing ptocedures based on free C source code written by
  136.   Joe C. Oliphant, CompuServe 71742, 1451, joe_oliphant@csufresno.edu }
  137.  
  138. const
  139.   MAX_COLORS = 4096;
  140.  
  141. type
  142.   PQColor = ^TQColor;
  143.   TQColor = record
  144.     RGB: array[0..2] of Byte;
  145.     NewColorIndex: Byte;
  146.     Count: Longint;
  147.     PNext: PQColor;
  148.   end;
  149.  
  150.   PQColorArray = ^TQColorArray;
  151.   TQColorArray = array[0..MAX_COLORS - 1] of TQColor;
  152.  
  153.   PQColorList = ^TQColorList;
  154.   TQColorList = array[0..MaxListSize - 1] of PQColor;
  155.  
  156.   PNewColor = ^TNewColor;
  157.   TNewColor = record
  158.     RGBMin, RGBWidth: array[0..2] of Byte;
  159.     NumEntries: Longint;
  160.     Count: Longint;
  161.     QuantizedColors: PQColor;
  162.   end;
  163.  
  164.   PNewColorArray = ^TNewColorArray;
  165.   TNewColorArray = array[Byte] of TNewColor;
  166.  
  167. procedure PInsert(ColorList: PQColorList; Number: Integer;
  168.   SortRGBAxis: Integer);
  169. var
  170.   Q1, Q2: PQColor;
  171.   I, J: Integer;
  172.   Temp: PQColor;
  173. begin
  174.   for I := 1 to Number - 1 do begin
  175.     Temp := ColorList^[I];
  176.     J := I - 1;
  177.     while (J >= 0) do begin
  178.       Q1 := Temp;
  179.       Q2 := ColorList^[J];
  180.       if (Q1^.RGB[SortRGBAxis] - Q2^.RGB[SortRGBAxis] > 0) then Break;
  181.       ColorList^[J + 1] := ColorList^[J];
  182.       Dec(J);
  183.     end;
  184.     ColorList^[J + 1] := Temp;
  185.   end;
  186. end;
  187.  
  188. procedure PSort(ColorList: PQColorList; Number: Integer;
  189.   SortRGBAxis: Integer);
  190. var
  191.   Q1, Q2: PQColor;
  192.   I, J, N, Nr: Integer;
  193.   Temp, Part: PQColor;
  194. begin
  195.   if Number < 8 then begin
  196.     PInsert(ColorList, Number, SortRGBAxis);
  197.     Exit;
  198.   end;
  199.   Part := ColorList^[Number div 2];
  200.   I := -1;
  201.   J := Number;
  202.   repeat
  203.     repeat
  204.       Inc(I);
  205.       Q1 := ColorList^[I];
  206.       Q2 := Part;
  207.       N := Q1^.RGB[SortRGBAxis] - Q2^.RGB[SortRGBAxis];
  208.     until (N >= 0);
  209.     repeat
  210.       Dec(J);
  211.       Q1 := ColorList^[J];
  212.       Q2 := Part;
  213.       N := Q1^.RGB[SortRGBAxis] - Q2^.RGB[SortRGBAxis];
  214.     until (N <= 0);
  215.     if (I >= J) then Break;
  216.     Temp := ColorList^[I];
  217.     ColorList^[I] := ColorList^[J];
  218.     ColorList^[J] := Temp;
  219.   until False;
  220.   Nr := Number - I;
  221.   if (I < Number div 2) then begin
  222.     PSort(ColorList, I, SortRGBAxis);
  223.     PSort(PQColorList(@ColorList^[I]), Nr, SortRGBAxis);
  224.   end
  225.   else begin
  226.     PSort(PQColorList(@ColorList^[I]), Nr, SortRGBAxis);
  227.     PSort(ColorList, I, SortRGBAxis);
  228.   end;
  229. end;
  230.  
  231. function DivideMap(NewColorSubdiv: PNewColorArray; ColorMapSize: Integer;
  232.   var NewColormapSize: Integer; lpStr: Pointer): Integer;
  233. var
  234.   I, J: {$IFDEF WIN32} Integer {$ELSE} Cardinal {$ENDIF};
  235.   MaxSize, Index: Integer;
  236.   NumEntries, MinColor,
  237.   MaxColor: {$IFDEF WIN32} Integer {$ELSE} Cardinal {$ENDIF};
  238.   Sum, Count: Longint;
  239.   QuantizedColor: PQColor;
  240.   SortArray: PQColorList;
  241.   SortRGBAxis: Integer;
  242. begin
  243.   Index := 0; SortRGBAxis := 0;
  244.   while (colormapsize > NewColormapSize) do begin
  245.     MaxSize := -1;
  246.     for I := 0 to NewColormapSize - 1 do begin
  247.       for J := 0 to 2 do begin
  248.         if (NewColorSubdiv^[I].RGBwidth[J] > MaxSize) and
  249.           (NewColorSubdiv^[I].NumEntries > 1) then
  250.         begin
  251.           MaxSize := NewColorSubdiv^[I].RGBwidth[J];
  252.           Index := I;
  253.           SortRGBAxis := J;
  254.         end;
  255.       end;
  256.     end;
  257.     if (MaxSize = -1) then begin
  258.       Result := 1;
  259.       Exit;
  260.     end;
  261.     SortArray := PQColorList(lpStr);
  262.     J := 0;
  263.     QuantizedColor := NewColorSubdiv^[Index].QuantizedColors;
  264.     while (J < NewColorSubdiv^[Index].NumEntries) and
  265.       (QuantizedColor <> nil) do
  266.     begin
  267.       SortArray^[J] := QuantizedColor;
  268.       Inc(J);
  269.       QuantizedColor := QuantizedColor^.pnext;
  270.     end;
  271.     PSort(SortArray, NewColorSubdiv^[Index].NumEntries, SortRGBAxis);
  272.     for J := 0 to NewColorSubdiv^[Index].NumEntries - 2 do
  273.       SortArray^[J]^.pnext := SortArray^[J + 1];
  274.     SortArray^[NewColorSubdiv^[Index].NumEntries - 1]^.pnext := nil;
  275.     NewColorSubdiv^[Index].QuantizedColors := SortArray^[0];
  276.     QuantizedColor := SortArray^[0];
  277.     Sum := NewColorSubdiv^[Index].Count div 2 - QuantizedColor^.Count;
  278.     NumEntries := 1;
  279.     Count := QuantizedColor^.Count;
  280.     Dec(Sum, QuantizedColor^.pnext^.Count);
  281.     while (Sum >= 0) and (QuantizedColor^.pnext <> nil) and
  282.       (QuantizedColor^.pnext^.pnext <> nil) do
  283.     begin
  284.       QuantizedColor := QuantizedColor^.pnext;
  285.       Inc(NumEntries);
  286.       Inc(Count, QuantizedColor^.Count);
  287.       Dec(Sum, QuantizedColor^.pnext^.Count);
  288.     end;
  289.     MaxColor := (QuantizedColor^.RGB[SortRGBAxis]) shl 4;
  290.     MinColor := (QuantizedColor^.pnext^.RGB[SortRGBAxis]) shl 4;
  291.     NewColorSubdiv^[NewColormapSize].QuantizedColors := QuantizedColor^.pnext;
  292.     QuantizedColor^.pnext := nil;
  293.     NewColorSubdiv^[NewColormapSize].Count := Count;
  294.     Dec(NewColorSubdiv^[Index].Count, Count);
  295.     NewColorSubdiv^[NewColormapSize].NumEntries :=
  296.       NewColorSubdiv^[Index].NumEntries - NumEntries;
  297.     NewColorSubdiv^[Index].NumEntries := NumEntries;
  298.     for J := 0 to 2 do begin
  299.       NewColorSubdiv^[NewColormapSize].RGBmin[J] :=
  300.         NewColorSubdiv^[Index].RGBmin[J];
  301.       NewColorSubdiv^[NewColormapSize].RGBwidth[J] :=
  302.         NewColorSubdiv^[Index].RGBwidth[J];
  303.     end;
  304.     NewColorSubdiv^[NewColormapSize].RGBwidth[SortRGBAxis] :=
  305.       NewColorSubdiv^[NewColormapSize].RGBmin[SortRGBAxis] +
  306.       NewColorSubdiv^[NewColormapSize].RGBwidth[SortRGBAxis] -
  307.       MinColor;
  308.     NewColorSubdiv^[NewColormapSize].RGBmin[SortRGBAxis] := MinColor;
  309.     NewColorSubdiv^[Index].RGBwidth[SortRGBAxis] :=
  310.       MaxColor - NewColorSubdiv^[Index].RGBmin[SortRGBAxis];
  311.     Inc(NewColormapSize);
  312.   end;
  313.   Result := 1;
  314. end;
  315.  
  316. function Quantize(const bmp: TBitmapInfoHeader; gptr, Data8: Pointer;
  317.   var ColorCount: Integer; var OutputColormap: TRGBPalette): Integer;
  318. type
  319.   PWord = ^Word;
  320. var
  321.   P: PByteArray;
  322.   LineBuffer, Data: Pointer;
  323.   LineWidth: Longint;
  324.   TmpLineWidth, NewLineWidth: Longint;
  325.   I, J: Longint;
  326.   Index: Word;
  327.   NewColormapSize, NumOfEntries: Integer;
  328.   Mems: Longint;
  329.   cRed, cGreen, cBlue: Longint;
  330.   lpStr, Temp, Tmp: Pointer;
  331.   NewColorSubdiv: PNewColorArray;
  332.   ColorArrayEntries: PQColorArray;
  333.   QuantizedColor: PQColor;
  334. begin
  335.   LineWidth := WidthBytes(Longint(bmp.biWidth) * bmp.biBitCount);
  336.   Mems := (Longint(SizeOf(TQColor)) * (MAX_COLORS)) +
  337.     (Longint(SizeOf(TNewColor)) * 256) + LineWidth +
  338.     (Longint(sizeof(PQCOLOR)) * (MAX_COLORS));
  339.   lpStr := AllocMemo(Mems);
  340.   try
  341.     Temp := AllocMemo(Longint(bmp.biWidth) * Longint(bmp.biHeight) *
  342.       SizeOf(Word));
  343.     try
  344.       ColorArrayEntries := PQColorArray(lpStr);
  345.       NewColorSubdiv := PNewColorArray(HugeOffset(lpStr,
  346.         Longint(sizeof(TQColor)) * (MAX_COLORS)));
  347.       LineBuffer := HugeOffset(lpStr, (Longint(sizeof(TQColor)) * (MAX_COLORS)) +
  348.         (Longint(sizeof(TNewColor)) * 256));
  349.       for I := 0 to MAX_COLORS - 1 do begin
  350.         ColorArrayEntries^[I].RGB[0] := I shr 8;
  351.         ColorArrayEntries^[I].RGB[1] := (I shr 4) and $0F;
  352.         ColorArrayEntries^[I].RGB[2] := I and $0F;
  353.         ColorArrayEntries^[I].Count := 0;
  354.       end;
  355.       Tmp := Temp;
  356.       for I := 0 to bmp.biHeight - 1 do begin
  357.         HMemCpy(LineBuffer, HugeOffset(gptr, (bmp.biHeight - 1 - I) *
  358.           LineWidth), LineWidth);
  359.         P := LineBuffer;
  360.         for J := 0 to bmp.biWidth - 1 do begin
  361.           Index := (Longint(P^[2] and $F0) shl 4) +
  362.             Longint(P^[1] and $F0) + (Longint(P^[0] and $F0) shr 4);
  363.           Inc(ColorArrayEntries^[Index].Count);
  364.           P := HugeOffset(P, 3);
  365.           PWord(Tmp)^ := Index;
  366.           Tmp := HugeOffset(Tmp, 2);
  367.         end;
  368.       end;
  369.       for I := 0 to 255 do begin
  370.         NewColorSubdiv^[I].QuantizedColors := nil;
  371.         NewColorSubdiv^[I].Count := 0;
  372.         NewColorSubdiv^[I].NumEntries := 0;
  373.         for J := 0 to 2 do begin
  374.           NewColorSubdiv^[I].RGBmin[J] := 0;
  375.           NewColorSubdiv^[I].RGBwidth[J] := 255;
  376.         end;
  377.       end;
  378.       I := 0;
  379.       while I < MAX_COLORS do begin
  380.         if ColorArrayEntries^[I].Count > 0 then Break;
  381.         Inc(I);
  382.       end;
  383.       QuantizedColor := @ColorArrayEntries^[I];
  384.       NewColorSubdiv^[0].QuantizedColors := @ColorArrayEntries^[I];
  385.       NumOfEntries := 1;
  386.       Inc(I);
  387.       while I < MAX_COLORS do begin
  388.         if ColorArrayEntries^[I].Count > 0 then begin
  389.           QuantizedColor^.pnext := @ColorArrayEntries^[I];
  390.           QuantizedColor := @ColorArrayEntries^[I];
  391.           Inc(NumOfEntries);
  392.         end;
  393.         Inc(I);
  394.       end;
  395.       QuantizedColor^.pnext := nil;
  396.       NewColorSubdiv^[0].NumEntries := NumOfEntries;
  397.       NewColorSubdiv^[0].Count := Longint(bmp.biWidth) * Longint(bmp.biHeight);
  398.       NewColormapSize := 1;
  399.       DivideMap(NewColorSubdiv, ColorCount, NewColormapSize,
  400.         HugeOffset(lpStr, Longint(SizeOf(TQColor)) * (MAX_COLORS) +
  401.         Longint(SizeOf(TNewColor)) * 256 + LineWidth));
  402.       if (NewColormapSize < ColorCount) then begin
  403.         for I := NewColormapSize to ColorCount - 1 do
  404.           FillChar(OutputColormap[I], SizeOf(TRGBQuad), 0);
  405.       end;
  406.       for I := 0 to NewColormapSize - 1 do begin
  407.         J := NewColorSubdiv^[I].NumEntries;
  408.         if J > 0 then begin
  409.           QuantizedColor := NewColorSubdiv^[I].QuantizedColors;
  410.           cRed := 0;
  411.           cGreen := 0;
  412.           cBlue := 0;
  413.           while (QuantizedColor <> nil) do begin
  414.             QuantizedColor^.NewColorIndex := I;
  415.             Inc(cRed, QuantizedColor^.RGB[0]);
  416.             Inc(cGreen, QuantizedColor^.RGB[1]);
  417.             Inc(cBlue, QuantizedColor^.RGB[2]);
  418.             QuantizedColor := QuantizedColor^.pnext;
  419.           end;
  420.           with OutputColormap[I] do begin
  421.             rgbRed := (Longint(cRed shl 4) or $0F) div J;
  422.             rgbGreen := (Longint(cGreen shl 4) or $0F) div J;
  423.             rgbBlue := (Longint(cBlue shl 4) or $0F) div J;
  424.             rgbReserved := 0;
  425.             if (rgbRed <= $10) and (rgbGreen <= $10) and (rgbBlue <= $10) then
  426.               FillChar(OutputColormap[I], SizeOf(TRGBQuad), 0); { clBlack }
  427.           end;
  428.         end;
  429.       end;
  430.       TmpLineWidth := Longint(bmp.biWidth) * SizeOf(Word);
  431.       NewLineWidth := WidthBytes(Longint(bmp.biWidth) * 8);
  432.       ZeroMemory(Data8, NewLineWidth * bmp.biHeight);
  433.       for I := 0 to bmp.biHeight - 1 do begin
  434.         LineBuffer := HugeOffset(Temp, (bmp.biHeight - 1 - I) * TmpLineWidth);
  435.         Data := HugeOffset(Data8, I * NewLineWidth);
  436.         for J := 0 to bmp.biWidth - 1 do begin
  437.           PByte(Data)^ := ColorArrayEntries^[PWord(LineBuffer)^].NewColorIndex;
  438.           LineBuffer := HugeOffset(LineBuffer, 2);
  439.           Data := HugeOffset(Data, 1);
  440.         end;
  441.       end;
  442.     finally
  443.       FreeMemo(Temp);
  444.     end;
  445.   finally
  446.     FreeMemo(lpStr);
  447.   end;
  448.   ColorCount := NewColormapSize;
  449.   Result := 0;
  450. end;
  451.  
  452. {
  453.   Procedures to truncate to lower bits-per-pixel, grayscale, tripel and
  454.   histogram conversion based on freeware C source code of GBM package by
  455.   Andy Key (nyangau@interalpha.co.uk). The home page of GBM author is
  456.   at http://www.interalpha.net/customer/nyangau/.
  457. }
  458.  
  459. { Truncate to lower bits per pixel }
  460.  
  461. type
  462.   TTruncLine = procedure(Src, Dest: Pointer; CX: Integer);
  463.  
  464. { For 6Rx6Gx6B, 7Rx8Gx4B palettes etc. }
  465.  
  466. const
  467.   Scale04: array[0..3] of Byte = (0, 85, 170, 255);
  468.   Scale06: array[0..5] of Byte = (0, 51, 102, 153, 204, 255);
  469.   Scale07: array[0..6] of Byte = (0, 43, 85, 128, 170, 213, 255);
  470.   Scale08: array[0..7] of Byte = (0, 36, 73, 109, 146, 182, 219, 255);
  471.  
  472. { For 6Rx6Gx6B, 7Rx8Gx4B palettes etc. }
  473.  
  474. var
  475.   TruncIndex04: array[Byte] of byte;
  476.   TruncIndex06: array[Byte] of byte;
  477.   TruncIndex07: array[Byte] of byte;
  478.   TruncIndex08: array[Byte] of byte;
  479.  
  480. { These functions initialises this module }
  481.  
  482. procedure InitTruncTables;
  483.  
  484.   function NearestIndex(Value: Byte; const Bytes: array of Byte): Byte;
  485.   var
  486.     B, I: Byte;
  487.     Diff, DiffMin: Word;
  488.   begin
  489.     Result := 0;
  490.     B := Bytes[0];
  491.     DiffMin := Abs(Value - B);
  492.     for I := 1 to High(Bytes) do begin
  493.       B := Bytes[I];
  494.       Diff := Abs(Value - B);
  495.       if Diff < DiffMin then begin
  496.         DiffMin := Diff;
  497.         Result := I;
  498.       end;
  499.     end;
  500.   end;
  501.  
  502. var
  503.   I: Integer;
  504. begin
  505.   { For 7 Red X 8 Green X 4 Blue palettes etc. }
  506.   for I := 0 to 255 do begin
  507.     TruncIndex04[I] := NearestIndex(Byte(I), Scale04);
  508.     TruncIndex06[I] := NearestIndex(Byte(I), Scale06);
  509.     TruncIndex07[I] := NearestIndex(Byte(I), Scale07);
  510.     TruncIndex08[I] := NearestIndex(Byte(I), Scale08);
  511.   end;
  512. end;
  513.  
  514. procedure Trunc(const Header: TBitmapInfoHeader; Src, Dest: Pointer;
  515.   DstBitsPerPixel: Integer; TruncLineProc: TTruncLine);
  516. var
  517.   SrcScanline, DstScanline: Longint;
  518.   Y: Integer;
  519. begin
  520.   SrcScanline := (Header.biWidth * 3 + 3) and not 3;
  521.   DstScanline := ((Header.biWidth * DstBitsPerPixel + 31) div 32) * 4;
  522.   for Y := 0 to Header.biHeight - 1 do
  523.     TruncLineProc(HugeOffset(Src, Y * SrcScanline),
  524.       HugeOffset(Dest, Y * DstScanline), Header.biWidth);
  525. end;
  526.  
  527. { return 6Rx6Gx6B palette
  528.   This function makes the palette for the 6 red X 6 green X 6 blue palette.
  529.   216 palette entrys used. Remaining 40 Left blank.
  530. }
  531. procedure TruncPal6R6G6B(var Colors: TRGBPalette);
  532. var
  533.   I, R, G, B: Byte;
  534. begin
  535.   FillChar(Colors, SizeOf(TRGBPalette), $80);
  536.   I := 0;
  537.   for R := 0 to 5 do
  538.     for G := 0 to 5 do
  539.       for B := 0 to 5 do begin
  540.         Colors[I].rgbRed := Scale06[R];
  541.         Colors[I].rgbGreen := Scale06[G];
  542.         Colors[I].rgbBlue := Scale06[B];
  543.         Colors[I].rgbReserved := 0;
  544.         Inc(I);
  545.       end;
  546. end;
  547.  
  548. { truncate to 6Rx6Gx6B one line }
  549. procedure TruncLine6R6G6B(Src, Dest: Pointer; CX: Integer); far;
  550. var
  551.   X: Integer;
  552.   R, G, B: Byte;
  553. begin
  554.   for X := 0 to CX - 1 do begin
  555.     B := TruncIndex06[Byte(Src^)]; Src := HugeOffset(Src, 1);
  556.     G := TruncIndex06[Byte(Src^)]; Src := HugeOffset(Src, 1);
  557.     R := TruncIndex06[Byte(Src^)]; Src := HugeOffset(Src, 1);
  558.     PByte(Dest)^ := 6 * (6 * R + G) + B;
  559.     Dest := HugeOffset(Dest, 1);
  560.   end;
  561. end;
  562.  
  563. { truncate to 6Rx6Gx6B }
  564. procedure Trunc6R6G6B(const Header: TBitmapInfoHeader;
  565.   const Data24, Data8: Pointer);
  566. begin
  567.   Trunc(Header, Data24, Data8, 8, TruncLine6R6G6B);
  568. end;
  569.  
  570. { return 7Rx8Gx4B palette
  571.   This function makes the palette for the 7 red X 8 green X 4 blue palette.
  572.   224 palette entrys used. Remaining 32 Left blank.
  573.   Colours calculated to match those used by 8514/A PM driver.
  574. }
  575. procedure TruncPal7R8G4B(var Colors: TRGBPalette);
  576. var
  577.   I, R, G, B: Byte;
  578. begin
  579.   FillChar(Colors, SizeOf(TRGBPalette), $80);
  580.   I := 0;
  581.   for R := 0 to 6 do
  582.     for G := 0 to 7 do
  583.       for B := 0 to 3 do begin
  584.         Colors[I].rgbRed := Scale07[R];
  585.         Colors[I].rgbGreen := Scale08[G];
  586.         Colors[I].rgbBlue := Scale04[B];
  587.         Colors[I].rgbReserved := 0;
  588.         Inc(I);
  589.       end;
  590. end;
  591.  
  592. { truncate to 7Rx8Gx4B one line }
  593. procedure TruncLine7R8G4B(Src, Dest: Pointer; CX: Integer); far;
  594. var
  595.   X: Integer;
  596.   R, G, B: Byte;
  597. begin
  598.   for X := 0 to CX - 1 do begin
  599.     B := TruncIndex04[Byte(Src^)]; Src := HugeOffset(Src, 1);
  600.     G := TruncIndex08[Byte(Src^)]; Src := HugeOffset(Src, 1);
  601.     R := TruncIndex07[Byte(Src^)]; Src := HugeOffset(Src, 1);
  602.     PByte(Dest)^ := 4 * (8 * R + G) + B;
  603.     Dest := HugeOffset(Dest, 1);
  604.   end;
  605. end;
  606.  
  607. { truncate to 7Rx8Gx4B }
  608. procedure Trunc7R8G4B(const Header: TBitmapInfoHeader;
  609.   const Data24, Data8: Pointer);
  610. begin
  611.   Trunc(Header, Data24, Data8, 8, TruncLine7R8G4B);
  612. end;
  613.  
  614. { Grayscale support }
  615.  
  616. procedure GrayPal(var Colors: TRGBPalette);
  617. var
  618.   I: Byte;
  619. begin
  620.   FillChar(Colors, SizeOf(TRGBPalette), 0);
  621.   for I := 0 to 255 do FillChar(Colors[I], 3, I);
  622. end;
  623.  
  624. procedure Grayscale(const Header: TBitmapInfoHeader; Data24, Data8: Pointer);
  625. var
  626.   SrcScanline, DstScanline: Longint;
  627.   Y, X: Integer;
  628.   Src, Dest: PByte;
  629.   R, G, B: Byte;
  630. begin
  631.   SrcScanline := (Header.biWidth * 3 + 3) and not 3;
  632.   DstScanline := (Header.biWidth + 3) and not 3;
  633.   for Y := 0 to Header.biHeight - 1 do begin
  634.     Src := Data24;
  635.     Dest := Data8;
  636.     for X := 0 to Header.biWidth - 1 do begin
  637.       B := Src^; Src := HugeOffset(Src, 1);
  638.       G := Src^; Src := HugeOffset(Src, 1);
  639.       R := Src^; Src := HugeOffset(Src, 1);
  640.       Dest^ := Byte(Longint(Word(R) * 77 + Word(G) * 150 + Word(B) * 29) shr 8);
  641.       Dest := HugeOffset(Dest, 1);
  642.     end;
  643.     Data24 := HugeOffset(Data24, SrcScanline);
  644.     Data8 := HugeOffset(Data8, DstScanline);
  645.   end;
  646. end;
  647.  
  648. { Tripel conversion }
  649.  
  650. procedure TripelPal(var Colors: TRGBPalette);
  651. var
  652.   I: Byte;
  653. begin
  654.   FillChar(Colors, SizeOf(TRGBPalette), 0);
  655.   for I := 0 to $40 do begin
  656.     Colors[I].rgbRed := I shl 2;
  657.     Colors[I + $40].rgbGreen := I shl 2;
  658.     Colors[I + $80].rgbBlue := I shl 2;
  659.   end;
  660. end;
  661.  
  662. procedure Tripel(const Header: TBitmapInfoHeader; Data24, Data8: Pointer);
  663. var
  664.   SrcScanline, DstScanline: Longint;
  665.   Y, X: Integer;
  666.   Src, Dest: PByte;
  667.   R, G, B: Byte;
  668. begin
  669.   SrcScanline := (Header.biWidth * 3 + 3) and not 3;
  670.   DstScanline := (Header.biWidth + 3) and not 3;
  671.   for Y := 0 to Header.biHeight - 1 do begin
  672.     Src := Data24;
  673.     Dest := Data8;
  674.     for X := 0 to Header.biWidth - 1 do begin
  675.       B := Src^; Src := HugeOffset(Src, 1);
  676.       G := Src^; Src := HugeOffset(Src, 1);
  677.       R := Src^; Src := HugeOffset(Src, 1);
  678.       case ((X + Y) mod 3) of
  679.         0: Dest^ := Byte(R shr 2);
  680.         1: Dest^ := Byte($40 + (G shr 2));
  681.         2: Dest^ := Byte($80 + (B shr 2));
  682.       end;
  683.       Dest := HugeOffset(Dest, 1);
  684.     end;
  685.     Data24 := HugeOffset(Data24, SrcScanline);
  686.     Data8 := HugeOffset(Data8, DstScanline);
  687.   end;
  688. end;
  689.  
  690. { Histogram/Frequency-of-use method of color reduction }
  691.  
  692. const
  693.   MAX_N_COLS = 2049;
  694.   MAX_N_HASH = 5191;
  695.  
  696. function Hash(R, G, B: Byte): Word;
  697. begin
  698.   Result := Word(Longint(Longint(R + G) * Longint(G + B) *
  699.     Longint(B + R)) mod MAX_N_HASH);
  700. end;
  701.  
  702. type
  703.   PFreqRecord = ^TFreqRecord;
  704.   TFreqRecord = record
  705.     B, G, R: Byte;
  706.     Frequency: Longint;
  707.     Nearest: Byte;
  708.   end;
  709.  
  710.   PHist = ^THist;
  711.   THist = record
  712.     ColCount: Longint;
  713.     Rm, Gm, Bm: Byte;
  714.     Freqs: array[0..MAX_N_COLS - 1] of TFreqRecord;
  715.     HashTable: array[0..MAX_N_HASH - 1] of Word;
  716.   end;
  717.  
  718. function CreateHistogram(R, G, B: Byte): PHist;
  719. { create empty histogram }
  720. begin
  721.   GetMem(Result, SizeOf(THist));
  722.   with Result^ do begin
  723.     Rm := R;
  724.     Gm := G;
  725.     Bm := B;
  726.     ColCount := 0;
  727.   end;
  728.   FillChar(Result^.HashTable, MAX_N_HASH * SizeOf(Word), 255);
  729. end;
  730.  
  731. procedure ClearHistogram(var Hist: PHist; R, G, B: Byte);
  732. begin
  733.   with Hist^ do begin
  734.     Rm := R;
  735.     Gm := G;
  736.     Bm := B;
  737.     ColCount := 0;
  738.   end;
  739.   FillChar(Hist^.HashTable, MAX_N_HASH * SizeOf(Word), 255);
  740. end;
  741.  
  742. procedure DeleteHistogram(var Hist: PHist);
  743. begin
  744.   FreeMem(Hist, SizeOf(THist));
  745.   Hist := nil;
  746. end;
  747.  
  748. function AddToHistogram(var Hist: THist; const Header: TBitmapInfoHeader;
  749.   Data24: Pointer): Boolean;
  750. { add bitmap data to histogram }
  751. var
  752.   Step24: Integer;
  753.   HashColor, Index: Word;
  754.   Rm, Gm, Bm, R, G, B: Byte;
  755.   X, Y, ColCount: Longint;
  756. begin
  757.   Step24 := ((Header.biWidth * 3 + 3) and not 3) - Header.biWidth * 3;
  758.   Rm := Hist.Rm;
  759.   Gm := Hist.Gm;
  760.   Bm := Hist.Bm;
  761.   ColCount := Hist.ColCount;
  762.   for Y := 0 to Header.biHeight - 1 do begin
  763.     for X := 0 to Header.biWidth - 1 do begin
  764.       B := Byte(Data24^) and Bm; Data24 := HugeOffset(Data24, 1);
  765.       G := Byte(Data24^) and Gm; Data24 := HugeOffset(Data24, 1);
  766.       R := Byte(Data24^) and Rm; Data24 := HugeOffset(Data24, 1);
  767.       HashColor := Hash(R, G, B);
  768.       repeat
  769.         Index := Hist.HashTable[HashColor];
  770.         if (Index = $FFFF) or ((Hist.Freqs[Index].R = R) and
  771.           (Hist.Freqs[Index].G = G) and (Hist.Freqs[Index].B = B)) then Break;
  772.         Inc(HashColor);
  773.         if (HashColor = MAX_N_HASH) then HashColor := 0;
  774.       until False;
  775.       { Note: loop will always be broken out of }
  776.       { We don't allow HashTable to fill up above half full }
  777.       if (Index = $FFFF) then begin
  778.         { Not found in Hash table }
  779.         if (ColCount = MAX_N_COLS) then begin
  780.           Result := False;
  781.           Exit;
  782.         end;
  783.         Hist.Freqs[ColCount].Frequency := 1;
  784.         Hist.Freqs[ColCount].B := B;
  785.         Hist.Freqs[ColCount].G := G;
  786.         Hist.Freqs[ColCount].R := R;
  787.         Hist.HashTable[HashColor] := ColCount;
  788.         Inc(ColCount);
  789.       end
  790.       else begin
  791.         { Found in Hash table, update index }
  792.         Inc(Hist.Freqs[Index].Frequency);
  793.       end;
  794.     end;
  795.     Data24 := HugeOffset(Data24, Step24);
  796.   end;
  797.   Hist.ColCount := ColCount;
  798.   Result := True;
  799. end;
  800.  
  801. procedure PalHistogram(var Hist: THist; var Colors: TRGBPalette;
  802.   ColorsWanted: Integer);
  803. { work out a palette from Hist }
  804. var
  805.   I, J: Longint;
  806.   MinDist, Dist: Longint;
  807.   MaxJ, MinJ: Longint;
  808.   DeltaB, DeltaG, DeltaR: Longint;
  809.   MaxFreq: Longint;
  810. begin
  811.   I := 0; MaxJ := 0; MinJ := 0;
  812.   { Now find the ColorsWanted most frequently used ones }
  813.   while (I < ColorsWanted) and (I < Hist.ColCount) do begin
  814.     MaxFreq := 0;
  815.     for J := 0 to Hist.ColCount - 1 do
  816.       if (Hist.Freqs[J].Frequency > MaxFreq) then begin
  817.         MaxJ := J;
  818.         MaxFreq := Hist.Freqs[J].Frequency;
  819.       end;
  820.     Hist.Freqs[MaxJ].Nearest := Byte(I);
  821.     Hist.Freqs[MaxJ].Frequency := 0;  { Prevent later use of Freqs[MaxJ] }
  822.     Colors[I].rgbBlue := Hist.Freqs[MaxJ].B;
  823.     Colors[I].rgbGreen := Hist.Freqs[MaxJ].G;
  824.     Colors[I].rgbRed := Hist.Freqs[MaxJ].R;
  825.     Colors[I].rgbReserved := 0;
  826.     Inc(I);
  827.   end;
  828.   { Unused palette entries will be medium grey }
  829.   while I <= 255 do begin
  830.     Colors[I].rgbRed := $80;
  831.     Colors[I].rgbGreen := $80;
  832.     Colors[I].rgbBlue := $80;
  833.     Colors[I].rgbReserved := 0;
  834.     Inc(I);
  835.   end;
  836.   { For the rest, find the closest one in the first ColorsWanted }
  837.   for I := 0 to Hist.ColCount - 1 do begin
  838.     if Hist.Freqs[I].Frequency <> 0 then begin
  839.       MinDist := 3 * 256 * 256;
  840.       for J := 0 to ColorsWanted - 1 do begin
  841.         DeltaB := Hist.Freqs[I].B - Colors[J].rgbBlue;
  842.         DeltaG := Hist.Freqs[I].G - Colors[J].rgbGreen;
  843.         DeltaR := Hist.Freqs[I].R - Colors[J].rgbRed;
  844.         Dist := Longint(DeltaR * DeltaR) + Longint(DeltaG * DeltaG) +
  845.           Longint(DeltaB * DeltaB);
  846.         if (Dist < MinDist) then begin
  847.           MinDist := Dist;
  848.           MinJ := J;
  849.         end;
  850.       end;
  851.       Hist.Freqs[I].Nearest := Byte(MinJ);
  852.     end;
  853.   end;
  854. end;
  855.  
  856. procedure MapHistogram(var Hist: THist; const Header: TBitmapInfoHeader;
  857.   Data24, Data8: Pointer);
  858. { map bitmap data to Hist palette }
  859. var
  860.   Step24: Integer;
  861.   Step8: Integer;
  862.   HashColor, Index: Longint;
  863.   Rm, Gm, Bm, R, G, B: Byte;
  864.   X, Y: Longint;
  865. begin
  866.   Step24 := ((Header.biWidth * 3 + 3) and not 3) - Header.biWidth * 3;
  867.   Step8 := ((Header.biWidth + 3) and not 3) - Header.biWidth;
  868.   Rm := Hist.Rm;
  869.   Gm := Hist.Gm;
  870.   Bm := Hist.Bm;
  871.   for Y := 0 to Header.biHeight - 1 do begin
  872.     for X := 0 to Header.biWidth - 1 do begin
  873.       B := Byte(Data24^) and Bm; Data24 := HugeOffset(Data24, 1);
  874.       G := Byte(Data24^) and Gm; Data24 := HugeOffset(Data24, 1);
  875.       R := Byte(Data24^) and Rm; Data24 := HugeOffset(Data24, 1);
  876.       HashColor := Hash(R, G, B);
  877.       repeat
  878.         Index := Hist.HashTable[HashColor];
  879.         if (Hist.Freqs[Index].R = R) and (Hist.Freqs[Index].G = G) and
  880.           (Hist.Freqs[Index].B = B) then Break;
  881.         Inc(HashColor);
  882.         if (HashColor = MAX_N_HASH) then HashColor := 0;
  883.       until False;
  884.       PByte(Data8)^ := Hist.Freqs[Index].Nearest;
  885.       Data8 := HugeOffset(Data8, 1);
  886.     end;
  887.     Data24 := HugeOffset(Data24, Step24);
  888.     Data8 := HugeOffset(Data8, Step8);
  889.   end;
  890. end;
  891.  
  892. procedure Histogram(const Header: TBitmapInfoHeader; var Colors: TRGBPalette;
  893.   Data24, Data8: Pointer; ColorsWanted: Integer; Rm, Gm, Bm: Byte);
  894. { map single bitmap to frequency optimised palette }
  895. var
  896.   Hist: PHist;
  897. begin
  898.   Hist := CreateHistogram(Rm, Gm, Bm);
  899.   try
  900.     repeat
  901.       if AddToHistogram(Hist^, Header, Data24) then Break
  902.       else begin
  903.         if (Gm > Rm) then Gm := Gm shl 1
  904.         else if (Rm > Bm) then Rm := Rm shl 1
  905.         else Bm := Bm shl 1;
  906.         ClearHistogram(Hist, Rm, Gm, Bm);
  907.       end;
  908.     until False;
  909.     { Above loop will always be exited as if masks get rough   }
  910.     { enough, ultimately number of unique colours < MAX_N_COLS }
  911.     PalHistogram(Hist^, Colors, ColorsWanted);
  912.     MapHistogram(Hist^, Header, Data24, Data8);
  913.   finally
  914.     DeleteHistogram(Hist);
  915.   end;
  916. end;
  917.  
  918. { expand to 24 bits-per-pixel }
  919.  
  920. (*
  921. procedure ExpandTo24Bit(const Header: TBitmapInfoHeader; Colors: TRGBPalette;
  922.   Data, NewData: Pointer);
  923. var
  924.   Scanline, NewScanline: Longint;
  925.   Y, X: Integer;
  926.   Src, Dest: Pointer;
  927.   C: Byte;
  928. begin
  929.   if Header.biBitCount = 24 then begin
  930.     Exit;
  931.   end;
  932.   Scanline := ((Header.biWidth * Header.biBitCount + 31) div 32) * 4;
  933.   NewScanline := ((Header.biWidth * 3 + 3) and not 3);
  934.   for Y := 0 to Header.biHeight - 1 do begin
  935.     Src := HugeOffset(Data, Y * Scanline);
  936.     Dest := HugeOffset(NewData, Y * NewScanline);
  937.     case Header.biBitCount of
  938.       1:
  939.       begin
  940.         C := 0;
  941.         for X := 0 to Header.biWidth - 1 do begin
  942.           if (X and 7) = 0 then begin
  943.             C := Byte(Src^);
  944.             Src := HugeOffset(Src, 1);
  945.           end
  946.           else C := C shl 1;
  947.           PByte(Dest)^ := Colors[C shr 7].rgbBlue;
  948.           Dest := HugeOffset(Dest, 1);
  949.           PByte(Dest)^ := Colors[C shr 7].rgbGreen;
  950.           Dest := HugeOffset(Dest, 1);
  951.           PByte(Dest)^ := Colors[C shr 7].rgbRed;
  952.           Dest := HugeOffset(Dest, 1);
  953.         end;
  954.       end;
  955.       4:
  956.       begin
  957.         X := 0;
  958.         while X < Header.biWidth - 1 do begin
  959.           C := Byte(Src^);
  960.           Src := HugeOffset(Src, 1);
  961.           PByte(Dest)^ := Colors[C shr 4].rgbBlue;
  962.           Dest := HugeOffset(Dest, 1);
  963.           PByte(Dest)^ := Colors[C shr 4].rgbGreen;
  964.           Dest := HugeOffset(Dest, 1);
  965.           PByte(Dest)^ := Colors[C shr 4].rgbRed;
  966.           Dest := HugeOffset(Dest, 1);
  967.           PByte(Dest)^ := Colors[C and 15].rgbBlue;
  968.           Dest := HugeOffset(Dest, 1);
  969.           PByte(Dest)^ := Colors[C and 15].rgbGreen;
  970.           Dest := HugeOffset(Dest, 1);
  971.           PByte(Dest)^ := Colors[C and 15].rgbRed;
  972.           Dest := HugeOffset(Dest, 1);
  973.           Inc(X, 2);
  974.         end;
  975.         if X < Header.biWidth then begin
  976.           C := Byte(Src^);
  977.           PByte(Dest)^ := Colors[C shr 4].rgbBlue;
  978.           Dest := HugeOffset(Dest, 1);
  979.           PByte(Dest)^ := Colors[C shr 4].rgbGreen;
  980.           Dest := HugeOffset(Dest, 1);
  981.           PByte(Dest)^ := Colors[C shr 4].rgbRed;
  982.           {Dest := HugeOffset(Dest, 1);}
  983.         end;
  984.       end;
  985.       8:
  986.       begin
  987.         for X := 0 to Header.biWidth - 1 do begin
  988.           C := Byte(Src^);
  989.           Src := HugeOffset(Src, 1);
  990.           PByte(Dest)^ := Colors[C].rgbBlue;
  991.           Dest := HugeOffset(Dest, 1);
  992.           PByte(Dest)^ := Colors[C].rgbGreen;
  993.           Dest := HugeOffset(Dest, 1);
  994.           PByte(Dest)^ := Colors[C].rgbRed;
  995.           Dest := HugeOffset(Dest, 1);
  996.         end;
  997.       end;
  998.     end;
  999.   end;
  1000. end;
  1001. *)
  1002.  
  1003. { DIB utility routines }
  1004.  
  1005. function GetPaletteBitmapFormat(Bitmap: TBitmap): TPixelFormat;
  1006. var
  1007.   PalSize: Integer;
  1008. begin
  1009.   Result := pfDevice;
  1010.   if Bitmap.Palette <> 0 then begin
  1011.     GetObject(Bitmap.Palette, SizeOf(Integer), @PalSize);
  1012.     if PalSize > 0 then begin
  1013.       if PalSize <= 2 then Result := pf1bit
  1014.       else if PalSize <= 16 then Result := pf4bit
  1015.       else if PalSize <= 256 then Result := pf8bit;
  1016.     end;
  1017.   end;
  1018. end;
  1019.  
  1020. function GetBitmapPixelFormat(Bitmap: TBitmap): TPixelFormat;
  1021. {$IFDEF RX_D3}
  1022. begin
  1023.   Result := Bitmap.PixelFormat;
  1024. {$ELSE}
  1025. var
  1026. {$IFDEF WIN32}
  1027.   BM: Windows.TBitmap;
  1028. {$ELSE}
  1029.   BM: WinTypes.TBitmap;
  1030. {$ENDIF}
  1031. begin
  1032.   Result := pfDevice;
  1033.   if Bitmap.Handle <> 0 then begin
  1034.     GetObject(Bitmap.Handle, SizeOf(BM), @BM);
  1035.     case BM.bmBitsPixel * BM.bmPlanes of
  1036.       1: Result := pf1bit;
  1037.       4: Result := pf4bit;
  1038.       8: Result := pf8bit;
  1039.       24: Result := pf24bit;
  1040.     end;
  1041.   end;
  1042. {$ENDIF}
  1043. end;
  1044.  
  1045. function BytesPerScanline(PixelsPerScanline, BitsPerPixel,
  1046.   Alignment: Longint): Longint;
  1047. begin
  1048.   Dec(Alignment);
  1049.   Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and
  1050.     not Alignment;
  1051.   Result := Result div 8;
  1052. end;
  1053.  
  1054. procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  1055.   PixelFormat: TPixelFormat);
  1056. {$IFDEF WIN32}
  1057. var
  1058.   DS: TDIBSection;
  1059.   Bytes: Integer;
  1060. begin
  1061.   DS.dsbmih.biSize := 0;
  1062.   Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
  1063.   if Bytes = 0 then InvalidBitmap
  1064.   else if (Bytes >= (SizeOf(DS.dsbm) + SizeOf(DS.dsbmih))) and
  1065.     (DS.dsbmih.biSize >= DWORD(SizeOf(DS.dsbmih))) then
  1066.     BI := DS.dsbmih
  1067.   else begin
  1068.     FillChar(BI, sizeof(BI), 0);
  1069.     with BI, DS.dsbm do begin
  1070.       biSize := SizeOf(BI);
  1071.       biWidth := bmWidth;
  1072.       biHeight := bmHeight;
  1073.     end;
  1074.   end;
  1075.   case PixelFormat of
  1076.     pf1bit: BI.biBitCount := 1;
  1077.     pf4bit: BI.biBitCount := 4;
  1078.     pf8bit: BI.biBitCount := 8;
  1079.     pf24bit: BI.biBitCount := 24;
  1080.     else BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
  1081.   end;
  1082.   BI.biPlanes := 1;
  1083.   if BI.biSizeImage = 0 then
  1084.     BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
  1085. end;
  1086. {$ELSE WIN32}
  1087. var
  1088.   BM: WinTypes.TBitmap;
  1089. begin
  1090.   GetObject(Bitmap, SizeOf(BM), @BM);
  1091.   with BI do begin
  1092.     biSize := SizeOf(BI);
  1093.     biWidth := BM.bmWidth;
  1094.     biHeight := BM.bmHeight;
  1095.     case PixelFormat of
  1096.       pf1bit: biBitCount := 1;
  1097.       pf4bit: biBitCount := 4;
  1098.       pf8bit: biBitCount := 8;
  1099.       pf24bit: biBitCount := 24;
  1100.       else biBitCount := BM.bmBitsPixel * BM.bmPlanes;
  1101.     end;
  1102.     biPlanes := 1;
  1103.     biXPelsPerMeter := 0;
  1104.     biYPelsPerMeter := 0;
  1105.     biClrUsed := 0;
  1106.     biClrImportant := 0;
  1107.     biCompression := BI_RGB;
  1108.     if biBitCount in [9..32] then biBitCount := 24;
  1109.     biSizeImage := (((biWidth * biBitCount + 31) div 32) * 4) * biHeight;
  1110.   end;
  1111. end;
  1112. {$ENDIF WIN32}
  1113.  
  1114. procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  1115.   var ImageSize: Longint; BitCount: TPixelFormat);
  1116. var
  1117.   BI: TBitmapInfoHeader;
  1118. begin
  1119.   InitializeBitmapInfoHeader(Bitmap, BI, BitCount);
  1120.   if BI.biBitCount > 8 then begin
  1121.     InfoHeaderSize := SizeOf(TBitmapInfoHeader);
  1122. {$IFDEF WIN32}
  1123.     if (BI.biCompression and BI_BITFIELDS) <> 0 then
  1124.       Inc(InfoHeaderSize, 12);
  1125. {$ENDIF}
  1126.   end
  1127.   else InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) *
  1128.     (1 shl BI.biBitCount);
  1129.   ImageSize := BI.biSizeImage;
  1130. end;
  1131.  
  1132. function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  1133.   var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;
  1134. var
  1135.   OldPal: HPALETTE;
  1136.   DC: HDC;
  1137. begin
  1138.   InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), PixelFormat);
  1139. {$IFDEF WIN32}
  1140.   with TBitmapInfoHeader(BitmapInfo) do biHeight := Abs(biHeight);
  1141. {$ENDIF}
  1142.   OldPal := 0;
  1143.   DC := CreateCompatibleDC(0);
  1144.   try
  1145.     if Palette <> 0 then
  1146.     begin
  1147.       OldPal := SelectPalette(DC, Palette, False);
  1148.       RealizePalette(DC);
  1149.     end;
  1150.     Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight,
  1151.       @Bits, TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
  1152.   finally
  1153.     if OldPal <> 0 then SelectPalette(DC, OldPal, False);
  1154.     DeleteDC(DC);
  1155.   end;
  1156. end;
  1157.  
  1158. function DIBFromBit(Src: HBITMAP; Pal: HPALETTE; PixelFormat: TPixelFormat;
  1159.   var Length: Longint): Pointer;
  1160. var
  1161.   HeaderSize: Integer;
  1162.   ImageSize: Longint;
  1163.   FileHeader: PBitmapFileHeader;
  1164.   BI: PBitmapInfoHeader;
  1165.   Bits: Pointer;
  1166. begin
  1167.   if Src = 0 then InvalidBitmap;
  1168.   InternalGetDIBSizes(Src, HeaderSize, ImageSize, PixelFormat);
  1169.   Length := SizeOf(TBitmapFileHeader) + HeaderSize + ImageSize;
  1170.   Result := AllocMemo(Length);
  1171.   try
  1172.     FillChar(Result^, Length, 0);
  1173.     FileHeader := Result;
  1174.     with FileHeader^ do
  1175.     begin
  1176.       bfType := $4D42;
  1177.       bfSize := Length;
  1178.       bfOffBits := SizeOf(FileHeader^) + HeaderSize;
  1179.     end;
  1180.     BI := PBitmapInfoHeader(Longint(FileHeader) + SizeOf(FileHeader^));
  1181.     Bits := Pointer(Longint(BI) + HeaderSize);
  1182.     InternalGetDIB(Src, Pal, BI^, Bits^, PixelFormat);
  1183.   except
  1184.     FreeMemo(Result);
  1185.     raise;
  1186.   end;
  1187. end;
  1188.  
  1189. { Change bits per pixel in a General Bitmap }
  1190.  
  1191. function BitmapToMemoryStream(Bitmap: TBitmap; PixelFormat: TPixelFormat;
  1192.   Method: TMappingMethod): TMemoryStream;
  1193. var
  1194.   FileHeader: PBitmapFileHeader;
  1195.   BI, NewBI: PBitmapInfoHeader;
  1196.   Bits: Pointer;
  1197.   NewPalette: PRGBPalette;
  1198.   NewHeaderSize: Integer;
  1199.   ImageSize, Length, Len: Longint;
  1200.   P, InitData: Pointer;
  1201.   ColorCount: Integer;
  1202. begin
  1203.   if Bitmap.Handle = 0 then InvalidBitmap;
  1204.   if (GetBitmapPixelFormat(Bitmap) = PixelFormat) and
  1205.     (Method <> mmGrayscale) then
  1206.   begin
  1207.     Result := TMemoryStream.Create;
  1208.     try
  1209.       Bitmap.SaveToStream(Result);
  1210.       Result.Position := 0;
  1211.     except
  1212.       Result.Free;
  1213.       raise;
  1214.     end;
  1215.     Exit;
  1216.   end;
  1217.   if not (PixelFormat in [pf1bit, pf4bit, pf8bit, pf24bit]) then
  1218.     NotImplemented
  1219.   else if (PixelFormat in [pf1bit, pf4Bit]) then begin
  1220.     P := DIBFromBit(Bitmap.Handle, Bitmap.Palette, PixelFormat, Length);
  1221.     try
  1222.       Result := TMemoryStream.Create;
  1223.       try
  1224.         Result.Write(P^, Length);
  1225.         Result.Position := 0;
  1226.       except
  1227.         Result.Free;
  1228.         raise;
  1229.       end;
  1230.     finally
  1231.       FreeMemo(P);
  1232.     end;
  1233.     Exit;
  1234.   end;
  1235.   { pf8bit - expand to 24bit first }
  1236.   InitData := DIBFromBit(Bitmap.Handle, Bitmap.Palette, pf24bit, Len);
  1237.   try
  1238.     BI := PBitmapInfoHeader(Longint(InitData) + SizeOf(TBitmapFileHeader));
  1239.     if BI^.biBitCount <> 24 then NotImplemented; {!!!}
  1240.     Bits := Pointer(Longint(BI) + SizeOf(TBitmapInfoHeader));
  1241.     InternalGetDIBSizes(Bitmap.Handle, NewHeaderSize, ImageSize, PixelFormat);
  1242.     Length := SizeOf(TBitmapFileHeader) + NewHeaderSize;
  1243.     P := AllocMemo(Length);
  1244.     try
  1245.       ZeroMemory(P, Length);
  1246.       NewBI := PBitmapInfoHeader(Longint(P) + SizeOf(TBitmapFileHeader));
  1247.       NewPalette := PRGBPalette(Longint(NewBI) + SizeOf(TBitmapInfoHeader));
  1248.       FileHeader := PBitmapFileHeader(P);
  1249.       InitializeBitmapInfoHeader(Bitmap.Handle, NewBI^, PixelFormat);
  1250.       case Method of
  1251.         mmQuantize:
  1252.           begin
  1253.             ColorCount := 256;
  1254.             Quantize(BI^, Bits, Bits, ColorCount, NewPalette^);
  1255.             NewBI^.biClrImportant := ColorCount;
  1256.           end;
  1257.         mmTrunc784:
  1258.           begin
  1259.             TruncPal7R8G4B(NewPalette^);
  1260.             Trunc7R8G4B(BI^, Bits, Bits);
  1261.             NewBI^.biClrImportant := 224;
  1262.           end;
  1263.         mmTrunc666:
  1264.           begin
  1265.             TruncPal6R6G6B(NewPalette^);
  1266.             Trunc6R6G6B(BI^, Bits, Bits);
  1267.             NewBI^.biClrImportant := 216;
  1268.           end;
  1269.         mmTripel:
  1270.           begin
  1271.             TripelPal(NewPalette^);
  1272.             Tripel(BI^, Bits, Bits);
  1273.           end;
  1274.         mmHistogram:
  1275.           begin
  1276.             Histogram(BI^, NewPalette^, Bits, Bits,
  1277.               PixelFormatToColors(PixelFormat), 255, 255, 255);
  1278.           end;
  1279.         mmGrayscale:
  1280.           begin
  1281.             GrayPal(NewPalette^);
  1282.             GrayScale(BI^, Bits, Bits);
  1283.           end;
  1284.       end;
  1285.       with FileHeader^ do begin
  1286.         bfType := $4D42;
  1287.         bfSize := Length;
  1288.         bfOffBits := SizeOf(FileHeader^) + NewHeaderSize;
  1289.       end;
  1290.       Result := TMemoryStream.Create;
  1291.       try
  1292.         Result.Write(P^, Length);
  1293.         Result.Write(Bits^, ImageSize);
  1294.         Result.Position := 0;
  1295.       except
  1296.         Result.Free;
  1297.         raise;
  1298.       end;
  1299.     finally
  1300.       FreeMemo(P);
  1301.     end;
  1302.   finally
  1303.     FreeMemo(InitData);
  1304.   end;
  1305. end;
  1306.  
  1307. function BitmapToMemory(Bitmap: TBitmap; Colors: Integer): TStream;
  1308. var
  1309.   PixelFormat: TPixelFormat;
  1310. begin
  1311.   if Colors <= 2 then PixelFormat := pf1bit
  1312.   else if Colors <= 16 then PixelFormat := pf4bit
  1313.   else if Colors <= 256 then PixelFormat := pf8bit
  1314.   else PixelFormat := pf24bit;
  1315.   Result := BitmapToMemoryStream(Bitmap, PixelFormat, DefaultMappingMethod);
  1316. end;
  1317.  
  1318. procedure SaveBitmapToFile(const Filename: string; Bitmap: TBitmap;
  1319.   Colors: Integer);
  1320. var
  1321.   Memory: TStream;
  1322. begin
  1323.   if Bitmap.Monochrome then Colors := 2;
  1324.   Memory := BitmapToMemory(Bitmap, Colors);
  1325.   try
  1326.     TMemoryStream(Memory).SaveToFile(Filename);
  1327.   finally
  1328.     Memory.Free;
  1329.   end;
  1330. end;
  1331.  
  1332. procedure SetBitmapPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat;
  1333.   Method: TMappingMethod);
  1334. var
  1335.   M: TMemoryStream;
  1336. begin
  1337.   if (Bitmap.Handle = 0) or (GetBitmapPixelFormat(Bitmap) = PixelFormat) then
  1338.     Exit;
  1339.   M := BitmapToMemoryStream(Bitmap, PixelFormat, Method);
  1340.   try
  1341.     Bitmap.LoadFromStream(M);
  1342.   finally
  1343.     M.Free;
  1344.   end;
  1345. end;
  1346.  
  1347. procedure GrayscaleBitmap(Bitmap: TBitmap);
  1348. begin
  1349.   SetBitmapPixelFormat(Bitmap, pf8bit, mmGrayscale);
  1350. end;
  1351.  
  1352. function ZoomImage(ImageW, ImageH, MaxW, MaxH: Integer; Stretch: Boolean): TPoint;
  1353. var
  1354.   Zoom: Double;
  1355. begin
  1356.   Result := Point(0, 0);
  1357.   if (MaxW <= 0) or (MaxH <= 0) or (ImageW <= 0) or (ImageH <= 0) then
  1358.     Exit;
  1359.   with Result do
  1360.     if Stretch then begin
  1361.       Zoom := MaxFloat([ImageW / MaxW, ImageH / MaxH]);
  1362.       if (Zoom > 0) then begin
  1363.         X := Round(ImageW * 0.98 / Zoom);
  1364.         Y := Round(ImageH * 0.98 / Zoom);
  1365.       end
  1366.       else begin
  1367.         X := ImageW;
  1368.         Y := ImageH;
  1369.       end;
  1370.     end
  1371.     else begin
  1372.       X := MaxW;
  1373.       Y := MaxH;
  1374.     end;
  1375. end;
  1376.  
  1377. procedure TileImage(Canvas: TCanvas; Rect: TRect; Image: TGraphic);
  1378. var
  1379.   X, Y: Integer;
  1380.   SaveIndex: Integer;
  1381. begin
  1382.   if (Image.Width = 0) or (Image.Height = 0) then Exit;
  1383.   SaveIndex := SaveDC(Canvas.Handle);
  1384.   try
  1385.     with Rect do
  1386.       IntersectClipRect(Canvas.Handle, Left, Top, Right, Bottom);
  1387.     for X := 0 to (WidthOf(Rect) div Image.Width) do
  1388.       for Y := 0 to (HeightOf(Rect) div Image.Height) do
  1389.         Canvas.Draw(Rect.Left + X * Image.Width,
  1390.           Rect.Top + Y * Image.Height, Image);
  1391.   finally
  1392.     RestoreDC(Canvas.Handle, SaveIndex);
  1393.   end;
  1394. end;
  1395.  
  1396. { TRxGradient }
  1397.  
  1398. constructor TRxGradient.Create;
  1399. begin
  1400.   inherited Create;
  1401.   FStartColor := clSilver;
  1402.   FEndColor := clGray;
  1403.   FStepCount := 64;
  1404.   FDirection := fdTopToBottom;
  1405. end;
  1406.  
  1407. procedure TRxGradient.Assign(Source: TPersistent);
  1408. begin
  1409.   if Source is TRxGradient then begin
  1410.     with TRxGradient(Source) do begin
  1411.       Self.FStartColor := StartColor;
  1412.       Self.FEndColor := EndColor;
  1413.       Self.FStepCount := StepCount;
  1414.       Self.FDirection := Direction;
  1415.       Self.FVisible := Visible;
  1416.     end;
  1417.     Changed;
  1418.   end
  1419.   else inherited Assign(Source);
  1420. end;
  1421.  
  1422. procedure TRxGradient.Changed;
  1423. begin
  1424.   if Assigned(FOnChange) then FOnChange(Self);
  1425. end;
  1426.  
  1427. procedure TRxGradient.Draw(Canvas: TCanvas; Rect: TRect);
  1428. begin
  1429.   GradientFillRect(Canvas, Rect, FStartColor, FEndColor, FDirection,
  1430.     FStepCount);
  1431. end;
  1432.  
  1433. procedure TRxGradient.SetStartColor(Value: TColor);
  1434. begin
  1435.   if Value <> FStartColor then begin
  1436.     FStartColor := Value;
  1437.     Changed;
  1438.   end;
  1439. end;
  1440.  
  1441. procedure TRxGradient.SetEndColor(Value: TColor);
  1442. begin
  1443.   if Value <> FEndColor then begin
  1444.     FEndColor := Value;
  1445.     Changed;
  1446.   end;
  1447. end;
  1448.  
  1449. procedure TRxGradient.SetDirection(Value: TFillDirection);
  1450. begin
  1451.   if Value <> FDirection then begin
  1452.     FDirection := Value;
  1453.     Changed;
  1454.   end;
  1455. end;
  1456.  
  1457. procedure TRxGradient.SetStepCount(Value: Byte);
  1458. begin
  1459.   if Value <> FStepCount then begin
  1460.     FStepCount := Value;
  1461.     Changed;
  1462.   end;
  1463. end;
  1464.  
  1465. procedure TRxGradient.SetVisible(Value: Boolean);
  1466. begin
  1467.   if FVisible <> Value then begin
  1468.     FVisible := Value;
  1469.     Changed;
  1470.   end;
  1471. end;
  1472.  
  1473. initialization
  1474.   InitTruncTables;
  1475. end.